home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / tp4gif.zip / TP4GIF.PAS < prev   
Pascal/Delphi Source File  |  1990-09-22  |  14KB  |  479 lines
  1. {\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  2. This file is not copyrighted.  No rights reserved.  Copy and modify at will.
  3.  
  4.         File : TP4GIF.PAS
  5.         Type : Mainline
  6.     Language : Turbo Pascal 4.0
  7.     Revision : 1
  8.       Author : Jim Griebel
  9.         Date : 01-16-88
  10.  Description : GIFSLOW experimental GIF file viewer.  Picked off of the
  11.                Milwaukee Exec-PC BBS.
  12.  
  13.     Revision : 2
  14.       Author : Rob Henningsgard
  15.         Date : 02-11-90
  16.  Description : Quickly cleaned up a few bugs (notably a range check error in
  17.                procedure ReadCode), improved speed around 9x.  Still needs
  18.                a lot of work.  Only mode tested was EGA 640 x 350.
  19.  
  20. \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}
  21. {$R-}{$S-}{$B-}
  22. program TP4GIF;
  23.  
  24. uses crt,GRAPH;
  25.  
  26. const
  27.   ProgramName = 'TP4GIF';
  28.   ProgramRevision = '2';
  29.  
  30. type
  31.   BufferArray = array[0..63999] of byte;
  32.   BufferPointer = ^BufferArray;
  33.  
  34. var
  35.   GifFile : file of BufferArray;
  36.   InputFileName : string;
  37.   RawBytes : BufferPointer;   { The heap array to hold it, raw    }
  38.   Buffer : BufferPointer;     { The Buffer data stream, unblocked }
  39.   Buffer2 : BufferPointer;    { More Buffer data stream if needed }
  40.   Byteoffset,                 { Computed byte position in Buffer array }
  41.   BitIndex                    { Bit offset of next code in Buffer array }
  42.    : longint;
  43.  
  44.   Width,      {Read from GIF header, image width}
  45.   Height,     { ditto, image height}
  46.   LeftOfs,    { ditto, image offset from left}
  47.   TopOfs,     { ditto, image offset from top}
  48.   RWidth,     { ditto, Buffer width}
  49.   RHeight,    { ditto, Buffer height}
  50.   ClearCode,  {GIF clear code}
  51.   EOFCode,    {GIF end-of-information code}
  52.   OutCount,   {Decompressor output 'stack count'}
  53.   MaxCode,    {Decompressor limiting value for current code size}
  54.   CurCode,    {Decompressor variable}
  55.   OldCode,    {Decompressor variable}
  56.   InCode,     {Decompressor variable}
  57.   FirstFree,  {First free code, generated per GIF spec}
  58.   FreeCode,   {Decompressor, next free slot in hash table}
  59.   RawIndex,     {Array pointers used during file read}
  60.   BufferPtr,
  61.   XC,YC,      {Screen X and Y coords of current pixel}
  62.   ReadMask,   {Code AND mask for current code size}
  63.   I           {Loop counter, what else?}
  64.   :word;
  65.  
  66.   Interlace,  {true if interlaced image}
  67.   AnotherBuffer, {true if file > 64000 bytes}
  68.   ColorMap    {true if colormap present}
  69.   : boolean;
  70.  
  71.   ch : char;
  72.   a,              {Utility}
  73.   Resolution,     {Resolution, read from GIF header}
  74.   BitsPerPixel,   {Bits per pixel, read from GIF header}
  75.   Background,     {Background color, read from GIF header}
  76.   ColorMapSize,   {Length of color map, from GIF header}
  77.   CodeSize,       {Code size, read from GIF header}
  78.   InitCodeSize,   {Starting code size, used during Clear}
  79.   FinChar,        {Decompressor variable}
  80.   Pass,           {Used by video output if interlaced pic}
  81.   BitMask,        {AND mask for data size}
  82.   R,G,B
  83.   :byte;
  84.  
  85.     {The hash table used by the decompressor}
  86.   Prefix: array[0..4095] of word;
  87.   Suffix: array[0..4095] of byte;
  88.  
  89.     {An output array used by the decompressor}
  90.   PixelValue : array[0..1024] of byte;
  91.  
  92.     {The color map, read from the GIF header}
  93.   Red,Green,Blue: array [0..255] of byte;
  94.   MyPalette : PaletteType;
  95.  
  96.   TempString : String;
  97.  
  98. Const
  99.   MaxCodes: Array [0..9] of Word = (4,8,16,$20,$40,$80,$100,$200,$400,$800);
  100.   CodeMask:Array [1..4] of byte= (1,3,7,15);
  101.   PowersOf2: Array [0..8] of word=(1,2,4,8,16,32,64,128,256);
  102.   Masks: Array [0..9] of integer = (7,15,$1f,$3f,$7f,$ff,$1ff,$3ff,$7ff,$fff);
  103.   BufferSize : Word = 64000;
  104.  
  105. function NewExtension(FileName,Extension : string) : string;
  106. {
  107. Places a new extension on to the file name.
  108. }
  109. var
  110.   I : integer;
  111. begin
  112.   if (Extension[1] = '.') then delete(Extension,1,1);
  113.   delete(Extension,4,251);
  114.   I := pos('.',FileName);
  115.   if (I = 0) then
  116.   begin
  117.     while (length(FileName) > 0) and (FileName[length(FileName)] = ' ')
  118.       do delete(FileName,length(FileName),1);
  119.     NewExtension := FileName + '.' + Extension;
  120.   end else begin
  121.     delete(FileName,I + 1,254 - I);
  122.     NewExtension := FileName + Extension;
  123.   end;
  124. end; { NewExtension }
  125.  
  126. function Min(I,J : longint) : longint;
  127. begin
  128.   if (I < J) then Min := I else Min := J;
  129. end; { Min }
  130.  
  131. procedure AllocMem(var P : BufferPointer);
  132. {
  133. This procedure checks to be sure we've got enough heap for the array
  134. we're trying to allocate, then allocates same. if there isn't enough
  135. heap available, we exit with an error
  136. }
  137. var
  138.   ASize : longint;
  139. begin
  140.   ASize := MaxAvail;
  141.   if (ASize < BufferSize) then begin
  142.     Textmode(15);
  143.     writeln('Insufficient memory available!');
  144.     halt;
  145.   end else getmem(P,BufferSize);
  146. end; { AllocMem }
  147.  
  148. function Getbyte : byte;
  149. begin
  150.   if (RawIndex >= BufferSize) then exit;
  151.   Getbyte := RawBytes^[RawIndex];
  152.   inc(RawIndex);
  153. end;
  154.  
  155. function Getword : word;
  156. var
  157.   W : word;
  158. begin
  159.   if (succ(RawIndex) >= BufferSize) then exit;
  160.   move(RawBytes^[RawIndex],W,2);
  161.   inc(RawIndex,2);
  162.   Getword := W;
  163. end; { GetWord }
  164.  
  165. procedure ReadBuffer;
  166. {
  167. Mimic reading in the Buffer data. Unblock it into a single large array
  168. to save having to do this as we go, which makes life a lot simpler for
  169. the rest of the program. We cope here with files larger than 64000 bytes by
  170. doing another read from the input file, and by creating a second Buffer
  171. array if necessary to hold the excess unblocked data
  172. }
  173. var
  174.   BlockLength : byte;
  175.   I,IOR : integer;
  176. begin
  177.   BufferPtr := 0;
  178.   Repeat
  179.     BlockLength := Getbyte;
  180.     For I := 0 to Blocklength-1 do
  181.     begin
  182.       if RawIndex = BufferSize then
  183.       begin
  184.         {$I-}
  185.         Read (GIFFile,RawBytes^);
  186.         {$I+}
  187.         IOR := IOResult;
  188.         RawIndex := 0;
  189.       end;
  190.       if not AnotherBuffer
  191.         then Buffer^[BufferPtr] := Getbyte
  192.         else Buffer2^[BufferPtr] := Getbyte;
  193.       BufferPtr := Succ (BufferPtr);
  194.       if BufferPtr=BufferSize then begin
  195.         AnotherBuffer := true;
  196.         BufferPtr := 0;
  197.         AllocMem (Buffer2);
  198.       end;
  199.     end;
  200.   Until Blocklength=0;
  201. end; { ReadBuffer }
  202.  
  203. procedure InitEGA;
  204. var
  205.   Driver,Mode : integer;
  206. begin
  207.   DetectGraph(Driver,Mode);
  208.   InitGraph(Driver,Mode,'');
  209.   SetAllPalette(MyPalette);
  210.   if (Background <> 0) then begin
  211.     SetFillStyle(SolidFill,Background);
  212.     bar(0,0,Width,Height);
  213.   end;
  214. end; { InitEGA }
  215.  
  216. procedure DetColor(var PValue : byte; MapValue : Byte);
  217. {
  218. Determine the palette value corresponding to the GIF colormap intensity
  219. value.
  220. }
  221. var
  222.   Local : byte;
  223. begin
  224.   PValue := MapValue div 64;
  225.   if (PValue = 1)
  226.     then PValue := 2
  227.     else if (PValue = 2)
  228.       then PValue := 1;
  229. end; { DetColor }
  230.  
  231. procedure Init;
  232. var
  233.   I : integer;
  234. begin
  235.   XC := 0;          {X and Y screen coords back to home}
  236.   YC := 0;
  237.   Pass := 0;        {Interlace pass counter back to 0}
  238.   BitIndex := 0;   {Point to the start of the Buffer data stream}
  239.   RawIndex := 0;      {Mock file read pointer back to 0}
  240.   AnotherBuffer := false;    {Over 64000 flag off}
  241.   AllocMem(Buffer);
  242.   AllocMem(RawBytes);
  243.   InputFileName := NewExtension(InputFileName,'GIF');
  244.   {$I-}
  245.   Assign(giffile,InputFileName);
  246.   Reset(giffile);
  247.   I := IOResult;
  248.   if (I <> 0) then begin
  249.     textmode(15);
  250.     writeln('Error opening file ',InputFileName,'. Press any key ');
  251.     readln;
  252.     halt;
  253.   end;
  254.   read(GIFFile,RawBytes^);
  255.   I := IOResult;
  256. {$I+}
  257. end; { Init }
  258.  
  259. procedure ReadGifHeader;
  260. var
  261.   I : integer;
  262. begin
  263.   TempString := '';
  264.   for I := 1 to 6 do TempString := TempString + chr(Getbyte);
  265.   if (TempString <> 'GIF87a') then begin
  266.     textmode(15);
  267.     writeln('Not a GIF file, or header read error. Press enter.');
  268.     readln;
  269.     halt;
  270.   end;
  271. {
  272. Get variables from the GIF screen descriptor
  273. }
  274.   RWidth := Getword;         {The Buffer width and height}
  275.   RHeight := Getword;
  276. {
  277. Get the packed byte immediately following and decode it
  278. }
  279.   B := Getbyte;
  280.   Colormap := (B and $80 = $80);
  281.   Resolution := B and $70 shr 5 + 1;
  282.   BitsPerPixel := B and 7 + 1;
  283.   ColorMapSize := 1 shl BitsPerPixel;
  284.   BitMask := CodeMask[BitsPerPixel];
  285.   Background := Getbyte;
  286.   B := Getbyte;         {Skip byte of 0's}
  287. {
  288. Compute size of colormap, and read in the global one if there. Compute
  289. values to be used when we set up the EGA palette
  290. }
  291.   MyPalette.Size := Min(ColorMapSize,16);
  292.   if Colormap then begin
  293.     for I := 0 to pred(ColorMapSize) do begin
  294.       Red[I] := Getbyte;
  295.       Green[I] := Getbyte;
  296.       Blue[I] := Getbyte;
  297.       DetColor(R,Red[I]);
  298.       DetColor(G,Green [I]);
  299.       DetColor(B,Blue [I]);
  300.       MyPalette.Colors[I] := B and 1 +
  301.                     ( 2 * (G and 1)) + ( 4 * (R and 1)) + (8 * (B div 2)) +
  302.                     (16 * (G div 2)) + (32 * (R div 2));
  303.     end;
  304.   end;
  305. {
  306. Now read in values from the image descriptor
  307. }
  308.   B := Getbyte;  {skip image seperator}
  309.   Leftofs := Getword;
  310.   Topofs := Getword;
  311.   Width := Getword;
  312.   Height := Getword;
  313.   A := Getbyte;
  314.   Interlace := (A and $40 = $40);
  315.   if Interlace then begin
  316.     textmode(15);
  317.     writeln(ProgramName,' is unable to display interlaced GIF pictures.');
  318.     halt;
  319.   end;
  320. end; { ReadGifHeader }
  321.  
  322. procedure PrepDecompressor;
  323. begin
  324.   Codesize := Getbyte;
  325.   ClearCode := PowersOf2[Codesize];
  326.   EOFCode := ClearCode + 1;
  327.   FirstFree := ClearCode + 2;
  328.   FreeCode := FirstFree;
  329.   inc(Codesize); { since zero means one... }
  330.   InitCodeSize := Codesize;
  331.   Maxcode := Maxcodes[Codesize - 2];
  332.   ReadMask := Masks[Codesize - 3];
  333. end; { PrepDecompressor }
  334.  
  335. procedure DisplayGIF;
  336. {
  337. Decompress and display the GIF data.
  338. }
  339. var
  340.   Code : word;
  341.  
  342.   procedure DoClear;
  343.   begin
  344.     CodeSize := InitCodeSize;
  345.     MaxCode := MaxCodes[CodeSize-2];
  346.     FreeCode := FirstFree;
  347.     ReadMask := Masks[CodeSize-3];
  348.   end; { DoClear }
  349.  
  350.   procedure ReadCode;
  351.   var
  352.     Raw : longint;
  353.   begin
  354.     if (CodeSize >= 8) then begin
  355.       move(Buffer^[BitIndex shr 3],Raw,3);
  356.       Code := (Raw shr (BitIndex mod 8)) and ReadMask;
  357.     end else begin
  358.       move(Buffer^[BitIndex shr 3],Code,2);
  359.       Code := (Code shr (BitIndex mod 8)) and ReadMask;
  360.     end;
  361.     if AnotherBuffer then begin
  362.       ByteOffset := BitIndex shr 3;
  363.       if (ByteOffset >= 63000) then begin
  364.         move(Buffer^[Byteoffset],Buffer^[0],BufferSize-Byteoffset);
  365.         move(Buffer2^[0],Buffer^[BufferSize-Byteoffset],63000);
  366.         BitIndex := BitIndex mod 8;
  367.         FreeMem(Buffer2,BufferSize);
  368.       end;
  369.     end;
  370.     BitIndex := BitIndex + CodeSize;
  371.   end; { ReadCode }
  372.  
  373.   procedure OutputPixel(Color : byte);
  374.   begin
  375.     putpixel(XC,YC,Color); { about 3x faster than using the DOS interrupt! }
  376.     inc(XC);
  377.     if (XC = Width) then begin
  378.       XC := 0;
  379.       inc(YC);
  380.       if (YC mod 10 = 0) and keypressed and (readkey = #27) then begin
  381.         textmode(15);  { let the user bail out }
  382.         halt;
  383.       end;
  384.     end;
  385.   end; { OutputPixel }
  386.  
  387. begin { DisplayGIF }
  388.   CurCode := 0; { not initted anywhere else... don't know why }
  389.   OldCode := 0; { not initted anywhere else... don't know why }
  390.   FinChar := 0; { not initted anywhere else... don't know why }
  391.   OutCount := 0;
  392.   DoClear;      { not initted anywhere else... don't know why }
  393.   repeat
  394.     ReadCode;
  395.     if (Code <> EOFCode) then begin
  396.       if (Code = ClearCode) then begin { restart decompressor }
  397.         DoClear;
  398.         ReadCode;
  399.         CurCode := Code;
  400.         OldCode := Code;
  401.         FinChar := Code and BitMask;
  402.         OutputPixel(FinChar);
  403.       end else begin        { must be data: save same as CurCode and InCode }
  404.         CurCode := Code;
  405.         InCode := Code;
  406. { if >= FreeCode, not in hash table yet; repeat the last character decoded }
  407.         if (Code >= FreeCode) then begin
  408.           CurCode := OldCode;
  409.           PixelValue[OutCount] := FinChar;
  410.           inc(OutCount);
  411.         end;
  412. {
  413. Unless this code is raw data, pursue the chain pointed to by CurCode
  414. through the hash table to its end; each code in the chain puts its
  415. associated output code on the output queue.
  416. }
  417.         if (CurCode > BitMask) then repeat
  418.           PixelValue[OutCount] := Suffix[CurCode];
  419.           inc(OutCount);
  420.           CurCode := Prefix[CurCode];
  421.         until (CurCode <= BitMask);
  422. {
  423. The last code in the chain is raw data.
  424. }
  425.         FinChar := CurCode and BitMask;
  426.         PixelValue[OutCount] := FinChar;
  427.         inc(OutCount);
  428. {
  429. Output the pixels. They're stacked Last In First Out.
  430. }
  431.         for I := pred(OutCount) downto 0 do OutputPixel(PixelValue[I]);
  432.         OutCount := 0;
  433. {
  434. Build the hash table on-the-fly.
  435. }
  436.         Prefix[FreeCode] := OldCode;
  437.         Suffix[FreeCode] := FinChar;
  438.         OldCode := InCode;
  439. {
  440. Point to the next slot in the table. If we exceed the current MaxCode
  441. value, increment the code size unless it's already 12. if it is, do
  442. nothing: the next code decompressed better be CLEAR
  443. }
  444.         inc(FreeCode);
  445.         if (FreeCode >= MaxCode) then begin
  446.           if (CodeSize < 12) then begin
  447.             inc(CodeSize);
  448.             MaxCode := MaxCode * 2;
  449.             ReadMask := Masks[CodeSize - 3];
  450.           end;
  451.         end;
  452.       end; {not Clear}
  453.     end; {not EOFCode}
  454.   until (Code = EOFCode);
  455. end; { DisplayGIF }
  456.  
  457. begin { TP4GIF }
  458.   writeln(ProgramName,' Rev ',ProgramRevision);
  459.   if (paramcount > 0)
  460.     then TempString := paramstr(1)
  461.   else begin
  462.     write(' > ');
  463.     readln(TempString);
  464.   end;
  465.   InputFileName := TempString;
  466.   Init;
  467.   ReadGifHeader;
  468.   PrepDecompressor;
  469.   ReadBuffer;
  470.   FreeMem(RawBytes,BufferSize);
  471.   InitEGA;
  472.   DisplayGIF;
  473.   SetAllPalette(MyPalette);
  474.   close(GifFile);
  475.   Ch := readkey;
  476.   textmode(15);
  477.   freemem(Buffer,BufferSize);        { totally pointless, but it's good form }
  478. end. { TP4GIF }
  479.